home *** CD-ROM | disk | FTP | other *** search
/ Apple Developer Connection Student Program / ADC Tools Sampler CD Disk 3 1999.iso / Cool Demos, SDKs, & Tools / Demos⁄Tools⁄Offers / Alpha ƒ / Tcl / Menus / ftpMenu.tcl < prev    next >
Text File  |  1999-05-12  |  12KB  |  455 lines
  1. ## -*-Tcl-*- (install)
  2. # ###################################################################
  3. #  Alpha - new Tcl folder configuration
  4. # 
  5. #  FILE: "ftpMenu.tcl"
  6. #                                    created: 20/7/96 {6:02:55 pm} 
  7. #                                last update: 05/12/1999 {22:01:37 PM} 
  8. #  
  9. #  Description: 
  10. # 
  11. # ###################################################################
  12. ##
  13.  
  14. alpha::menu ftpMenu 0.1.2 global "•141" {} {ftpMenu} {} uninstall {this-file} \
  15.   help {[editMark [file join $HOME Help "Alpha Manual"] "Ftp Browser" -r]}
  16.  
  17. hook::register savePostHook ftpPostHook
  18.  
  19. proc ftpMenu {} {}
  20.  
  21. proc ftpPostHook {name} {
  22.     global fetched
  23.     if {[info exists fetched($name)]} {
  24.     set specs $fetched($name)
  25.     # backwards compatibility
  26.     if {[lindex $specs 4] == ""} {
  27.         lappend specs "ftp"
  28.         set fetched($name) $specs
  29.     }
  30.     message "Updating '[file tail $name]' on [car $specs]…"
  31.     if {[string length [lindex $specs 1]]} {
  32.         ftpStore $name [lindex $specs 0] "[cadr $specs]/[file tail $name]" [caddr $specs] [cadddr $specs]
  33.     } else {
  34.         ftpStore $name [lindex $specs 0] "[file tail $name]" [caddr $specs] [cadddr $specs]
  35.     }
  36.     }
  37. }
  38.  
  39. proc rebuildFtpMenu {} {
  40.     global savedMounts recentMounts ftpMenu useCache
  41.     
  42.     Menu -n $ftpMenu -p ftpMenuProc {
  43.     help
  44.     "(-"
  45.     "<S/ibrowse…"
  46.     "<S/i<IbrowseCurrent…"
  47.     "/nbrowseMounts…"
  48.     "(-"
  49.     addMountPoint…
  50.     makePermanent…
  51.     removeMountPoint…
  52.     saveAsAt…
  53.     "(-"
  54.     useCache
  55.     flushCache
  56.     "(-"
  57.     "createFileset"
  58.     "(-"
  59.     }
  60.     markMenuItem -m $ftpMenu "Use Cache" $useCache
  61.     if {[info exists savedMounts]} {
  62.     foreach m [lsort -ignore [array names savedMounts]] {
  63.         addMenuItem -m -l "b " $ftpMenu $m
  64.     }
  65.     }
  66.     if {[info exists recentMounts]} {
  67.     addMenuItem -m $ftpMenu "(-"
  68.     foreach m [lsort -ignore [array names recentMounts]] {
  69.         addMenuItem -m -l "b " $ftpMenu $m
  70.     }
  71.     }
  72. }
  73.  
  74. if {![info exists useCache]} {set useCache 1}
  75.  
  76. app::registerMultiple ftp [list Arch FTCh] [list •141 •315] rebuildFtpMenu
  77.  
  78. proc mountPoints {} {
  79.     global savedMounts recentMounts
  80.     if {[info exists recentMounts]} {
  81.     if {[info exists savedMounts]} {
  82.         set l [concat [array names recentMounts] [array names savedMounts]]
  83.     } else {
  84.         set l [array names recentMounts]]
  85.     }
  86.     } else {
  87.     set l [array names savedMounts]
  88.     }
  89.     return [lsort $l]
  90. }
  91.  
  92.  
  93.  
  94. proc ftpMenuProc {menu item} {
  95.     global modifiedVars modifiedArrVars savedMounts recentMounts PREFS fetched HOME ftpMenu useCache createFtpType
  96.     switch -- $item {
  97.     help                {
  98.         editMark [file join $HOME Help "Alpha Manual"] "Ftp Browser" -r
  99.     }
  100.     browse                {
  101.         eval ftpBrowse [lrange [getLogin {Browse remote machine:} 0] 0 3]
  102.     }
  103.     browseCurrent        { 
  104.         if {[info exists fetched([win::Current])]} {
  105.         eval ftpBrowse $fetched([win::Current]) 
  106.         } else {
  107.         beep; message "'[win::CurrentTail]' not from remote host."
  108.         }
  109.     }
  110.     browseMounts        {
  111.         set l [mountPoints]
  112.         set res [listpick -p "Mount point:" $l]
  113.         if {[info exists recentMounts($res)]} {
  114.         eval ftpBrowse $recentMounts($res)
  115.         } else {
  116.         eval ftpBrowse $savedMounts($res)
  117.         }
  118.     }
  119.     
  120.     addMountPoint        { addMountPoint }
  121.     makePermanent        { makeMountPermanent }
  122.     createFileset        { newFileset ftp }
  123.     removeMountPoint    {
  124.         set pt [listpick -p "Remove which mount point?" [lsort -ignore [array names savedMounts]]]
  125.         unset savedMounts($pt)
  126.         removeArrDef savedMounts $pt
  127.         rebuildFtpMenu
  128.     }
  129.     saveAsAt            {
  130.         global fetched PREFS
  131.         set name [prompt "Name:" [win::CurrentTail]]
  132.         set point [listpick -p "At which mount point?" [mountPoints]]
  133.         if {[info exists recentMounts($point)]} {
  134.         set specs $recentMounts($point)
  135.         } else {
  136.         set specs $savedMounts($point)
  137.         }
  138.         # backwards compatibility
  139.         if {[lindex $specs 4] == ""} {
  140.         lappend specs "ftp"
  141.         }
  142.         set name [file join $PREFS ftptmp $name]
  143.         set fetched($name) $specs
  144.         message "Saving '$name' on [car $specs]…"
  145.         
  146.         if {![file exists $name]} {
  147.         set fid [open $name w]
  148.         close $fid
  149.         }
  150.         saveAs -f "$name"
  151.         
  152.         set num 0
  153.         set pathname [lindex $specs 1]
  154.         for {set i [expr [string length $pathname] - 1]} {$i >= 0} {incr i -1} {
  155.         scan $pathname "%c" char
  156.         incr num $char
  157.         }
  158.         
  159.         set nm [file join $PREFS ftptmp listing.$num]
  160.         catch {rm $nm}
  161.         
  162.         setWinInfo platform $createFtpType
  163.         setWinInfo dirty 1
  164.         save
  165.     }
  166.     
  167.     setDefaults            { 
  168.         global ftpDefaults modifiedVars
  169.         set ftpDefaults [lrange [getLogin "Enter defaults that you wish saved:" 0] 0 3]
  170.         lappend modifiedVars ftpDefaults
  171.     }
  172.     flushCache        { rm [file join $PREFS ftptmp *]; catch {unset recentMounts}; rebuildFtpMenu }
  173.     useCache    { 
  174.         set useCache [expr 1 - $useCache]
  175.         markMenuItem -m $ftpMenu "Use Cache" $useCache
  176.         lappend modifiedVars useCache
  177.     }
  178.     default {
  179.         if {[info exists recentMounts($item)]} {
  180.         eval ftpBrowse $recentMounts($item)
  181.         } else {
  182.         eval ftpBrowse $savedMounts($item)
  183.         }
  184.     }
  185.     }
  186. }
  187.  
  188.  
  189. proc ftpFilesetOpen {menu item} {
  190.     global gfileSets PREFS fetched fileSetsExtra
  191.     
  192.     set ind [lsearch $gfileSets($menu) "$item"]
  193.     if { $ind < 0 } { set ind [lsearch $gfileSets($menu) [file join * $item]] }
  194.  
  195.     if {$ind >= 0} {
  196.     set f [lindex $gfileSets($menu) $ind]
  197.     set lnm [file tail $f]
  198.     regsub -all {:} $f {/} f
  199.     set nm [file join $PREFS ftptmp $lnm]
  200.     set specs $fileSetsExtra($menu)
  201.     # backwards compatibility
  202.     if {[lindex $specs 4] == ""} {
  203.         lappend specs "ftp"
  204.         set fileSetsExtra($menu) $specs
  205.     }
  206.     if {![file exists $nm]} {
  207.         ftpFetch $nm [car $specs] $f [caddr $specs] [cadddr $specs]
  208.     }
  209.     edit -w $nm
  210.     set fetched($nm) $specs
  211.     }
  212. }
  213.  
  214.  
  215. proc ftpCreateFileset {} {
  216.     global gfileSets gfileSetsType PREFS fileSetsExtra
  217.     
  218.     set specs [getLogin]
  219.     set name [car $specs]
  220.     set host [cadr $specs]
  221.     set path [caddr $specs]
  222.     set user [cadddr $specs]
  223.     set password [caddddr $specs]
  224.     set pattern "^[prompt {Name pattern?} {.*.[ch]}]$"
  225.     set path [string trimright $path {/}]
  226.     
  227.     set fileSetsExtra($name) [list $host $path $user $password "ftp"]
  228.     
  229.     if { ![file exists [file join $PREFS ftptmp]] } {
  230.     file mkdir [file join $PREFS ftptmp]
  231.     }
  232.     set nm [file join $PREFS ftptmp listing.$path]
  233.     ftpList $nm $host $path $user $password
  234.     set files {}
  235.     foreach f [processListing $nm] {
  236.     if {![string match {*/} $f] && [regexp -- $pattern $f]} {
  237.         lappend files "$path/$f"
  238.     }
  239.     }
  240.     regsub -all {/} $files {:} files
  241.     
  242.     global gfileSets gfileSetsType
  243.     set gfileSets($name) [lsort -command sortByTail $files]
  244.     set gfileSetsType($name) ftp
  245.     if {[askyesno "Save project fileset?"] == "yes"} {
  246.     addArrDef gfileSetsType $name ftp
  247.     addArrDef gfileSets $name  $gfileSets($name)
  248.     addArrDef fileSetsExtra $name $fileSetsExtra($name)
  249.     }
  250.     return $name
  251. }
  252.  
  253.  
  254. proc processListing {path} {
  255.     set fd [open $path "r"]
  256.     set lines [split [read $fd] "\n"]
  257.     close $fd
  258.     set files {}
  259.     if {[llength $lines]} {
  260.     if {[string length [lindex $lines 0]] <= 10} {
  261.         set lines [cdr [lreplace $lines end end]]
  262.     } else {
  263.         set lines [lreplace $lines end end]
  264.     }
  265.     foreach f $lines {
  266.         set nm {}
  267.         regexp {[A-Z][a-z]+ [0-9, ]+ [0-9,:]+ (.*)$} $f dummy nm
  268.         if {[string length $nm]} {
  269.         if {[string match "d*" $f]} {
  270.             if {![string match "." $nm] && ![string match ".." $nm]} {
  271.             lappend files "$nm/"
  272.             }
  273.         } else {
  274.             lappend files $nm
  275.         }
  276.         }
  277.     }
  278.     } else {
  279.     error "empty list"
  280.     }
  281.     return $files
  282. }
  283.  
  284. proc getLogin {{prompt {All but 'password' are required:}} {nm 1}} {
  285.     global ftpDefaults
  286.     if {[info exists ftpDefaults]} {
  287.     set defs $ftpDefaults
  288.     } else {
  289.     set defs {"" "" "" ""}
  290.     }
  291.     set left 10
  292.     set right 100
  293.     set top 10
  294.     set bottom 30
  295.     set eleft [expr $left + 100]
  296.     set eright 370
  297.     set incr 30
  298.     
  299.     set height 198
  300.     
  301.     if {$nm} {incr height $incr}
  302.     set l "dialog -w 400 -h $height -t [list $prompt] $left $top 400 $bottom"
  303.     
  304.     if {$nm} {
  305.     incr top $incr
  306.     incr bottom $incr
  307.     lappend l -t {Name:} $left $top $right $bottom
  308.     lappend l -e {} $eleft $top $eright $bottom
  309.     }
  310.     
  311.     incr top $incr
  312.     incr bottom $incr
  313.     lappend l -t {Host:} $left $top $right $bottom
  314.     lappend l -e [car $defs] $eleft $top $eright $bottom
  315.     
  316.     incr top $incr
  317.     incr bottom $incr
  318.     lappend l -t {Path:} $left $top $right $bottom
  319.     lappend l -e [cadr $defs] $eleft $top $eright $bottom
  320.     
  321.     incr top $incr
  322.     incr bottom $incr
  323.     lappend l -t {UserID:} $left $top $right $bottom
  324.     lappend l -e [caddr $defs] $eleft $top $eright $bottom
  325.     
  326.     incr top $incr
  327.     incr bottom $incr
  328.     lappend l -t {Password:} $left $top $right $bottom
  329.     lappend l -e [cadddr $defs] $eleft [expr $top + 6] $eright [expr $bottom - 12]
  330.     
  331.     incr top [expr $incr + 10]
  332.     incr bottom [expr $incr + 10]
  333.     lappend l -b "OK" $left $top $right [expr $top + 20]
  334.     lappend l -b "Cancel" [expr $left + 200] $top [expr $right + 200] [expr $top + 20]
  335.     
  336.     set res [eval "$l"]
  337.     if {[lindex $res end]} {error "Cancel"}
  338.     return $res
  339. }
  340.  
  341.  
  342. proc addMountPoint {} {
  343.     global savedMounts modifiedArrVars
  344.     
  345.     set res [getLogin]
  346.     if {[lindex $res 5]} {
  347.     set savedMounts([car $res]) [concat [lrange $res 1 4] "ftp"]
  348.     lappend modifiedArrVars savedMounts
  349.     rebuildFtpMenu
  350.     }
  351. }
  352.  
  353.  
  354. proc makeMountPermanent {} {
  355.     global recentMounts savedMounts modifiedArrVars
  356.     if {![info exists recentMounts]} {
  357.     alertnote "You have no temporary mounts."
  358.     return
  359.     }
  360.     set res [listpick -p "Make which temporary mount point permanent?" [lsort [array names recentMounts]]]
  361.     set name [prompt "Name?" $res]
  362.     set savedMounts($name) $recentMounts($res)
  363.     unset recentMounts($res)
  364.     lappend modifiedArrVars savedMounts
  365.     rebuildFtpMenu
  366. }
  367.  
  368.  
  369. proc ftpPromptBrowse {} {
  370.     eval ftpBrowse [lrange [getLogin {Browse remote machine:} 0] 0 3]
  371. }
  372.  
  373. proc ftpBrowse {host dir user password {type "ftp"} {fname {}}} {
  374.     global PREFS fetched lastFtpDir recentMounts savedMounts useCache
  375.     
  376.     watchCursor
  377.     if {![string length $password]} {
  378.     set password [dialog::password "Password for ${host}:"]
  379.     }
  380.     
  381.     if {![file exists [file join $PREFS ftptmp]]} {
  382.     file mkdir [file join $PREFS ftptmp]
  383.     }
  384.     if {$dir == {-}} {
  385.     if {![info exists lastFtpDir] || ![string length $lastFtpDir]} {set lastFtpDir ""}
  386.     set dir [prompt "'$host' dir:" $lastFtpDir]
  387.     }
  388.     set dir [string trimright $dir {/}]
  389.     set lastFtpDir $dir
  390.     
  391.     set num 0
  392.     for {set i [expr [string length $dir] - 1]} {$i >= 0} {incr i -1} {
  393.     scan [string index $dir $i] "%c" char
  394.     incr num $char
  395.     }
  396.     
  397.     set nm [file join $PREFS ftptmp listing.$num]
  398.     
  399.     if {!$useCache || ![file exists $nm]} {
  400.     ftpList $nm $host $dir $user $password
  401.     }
  402.     if {[catch {processListing $nm} listing]} {
  403.     alertnote "Error fetching directory '$dir'"
  404.     error "Error fetching directory '$dir'"
  405.     }
  406.     set files [concat {..} $listing]
  407.     if {$fname != ""} {
  408.     set file [listpick -L $fname -p "$dir/" $files]
  409.     } else {
  410.     set file [listpick -p "$dir/" $files]
  411.     }
  412.     
  413.     if {$file == {..}} {
  414.     if {[regexp {(.+)/[^/]+} $dir dummy sub]} {
  415.         return [ftpBrowse $host $sub $user $password]
  416.     } else {
  417.         return [ftpBrowse $host "" $user $password]
  418.     }
  419.     }
  420.     
  421.     if {[string match {*/} $file]} {
  422.     if {[string length $dir]} {
  423.         return [ftpBrowse $host [string trimright "$dir/$file" {/}] $user $password]
  424.     } else {
  425.         return [ftpBrowse $host [string trimright "$file" {/}] $user $password]
  426.     }
  427.     }
  428.     
  429.     set entry [list $host $dir $user $password $type]
  430.     set new 1
  431.     foreach name [array names savedMounts] {
  432.     if {([car $savedMounts($name)] == [car $entry]) && ([cadr $savedMounts($name)] == [cadr $entry])} {
  433.         set new 0
  434.         break;
  435.     }
  436.     }
  437.     if {$new} {
  438.     set recentMounts($dir) $entry
  439.     rebuildFtpMenu
  440.     }
  441.     
  442.     set nm [file join $PREFS ftptmp $file]
  443.     if {!$useCache || ![file exists $nm]} {
  444.     if {[string length $dir]} {
  445.         ftpFetch $nm $host "$dir/$file" $user $password
  446.     } else {
  447.         ftpFetch $nm $host "$file" $user $password
  448.     }
  449.     }
  450.     edit -w $nm
  451.     set fetched($nm) [list $host $dir $user $password "ftp"]
  452. }
  453.  
  454.  
  455.